home *** CD-ROM | disk | FTP | other *** search
/ Creative Computers / Creative Computers CD-ROM, Volume 1 (Legendary Design Technologies, Inc.)(1994).iso / shareware / games / hextrix / hextrix.f < prev    next >
Text File  |  1994-11-17  |  19KB  |  880 lines
  1. \ Hextrix in J-Forth
  2. \ Author:  Kasper Østerbye
  3. \ Copyright 1991 Kasper Østerbye
  4. \ Version: 1.0
  5. \
  6. \ This game was written to find out the workings of simple amiga
  7. \ graphics and J-Forth in particular.
  8. \
  9. \ This is give-away-ware. This program is now yours! If you can convince
  10. \ anyone that they should by it, you deserve the profit - I would be
  11. \ interested in knowing though!
  12. \ I am not a poor student, so please do not send 5$ (An amiga 3000
  13. \ would be nice though), but any comments or questions are welcomed.
  14.  
  15. \ Kasper Østerbye
  16. \ Buderupholmvej 48
  17. \ 9530 Støvring, Denmark
  18. \ email: kasper@iesd.auc.dk
  19. \
  20. \ SPECIAL WARNING FOR THE FOOLS IN USA: Extensive game play can seriously
  21. \ hurt your hand, and you might develop tenosynovitis. There is two
  22. \ things to say about that. 1) It is not my fault, and 2) If you need
  23. \ treatment and cannot affort it, considder whom you give a wote next time!
  24.  
  25. \ mdh - slight mods to be compatible with new locals (v2.0+) in beta state,
  26. \       everything still works with V2.0 and earlier.  Final v2.0+ locals
  27. \       will be completely backward-compatible.
  28.  
  29. INCLUDE? NewWindow.Setup JU:AMIGA_GRAPH
  30. INCLUDE? ?CLOSEBOX JU:AMIGA_EVENTS
  31. INCLUDE? NewScreen.Setup JU:SCREEN_SUPPORT
  32. INCLUDE? { JU:LOCALS
  33. INCLUDE? EV.GETCLASS JU:AMIGA_EVENTS
  34. INCLUDE? CHOOSE JU:RANDOM
  35. INCLUDE? LOADRGB4() ju:graph_support
  36. INCLUDE? SPRITES JI:GRAPHICS/VIEW.j
  37. INCLUDE? SimpleSprite JI:GRAPHICS/SPRITE.j
  38. INCLUDE? GETSPRITE() JU:SPRITES
  39.  
  40.  
  41. INCLUDE? Pieces pieces.f
  42. ANEW TASK-HEXTRIX.f      \ added '.f' -- mdh
  43. decimal
  44.  
  45. \ ******************************************************
  46. \  GAME CONSTANTS
  47. \ ******************************************************
  48.  
  49.  
  50. 1 Constant bordercolor
  51. 13 constant borderwidth  \ should be odd to look good
  52. 23 constant borderheight
  53.  
  54.  
  55.  
  56.  
  57.  
  58. \ *****************************************************************
  59. \      SCREEN AND WINDOW
  60. \ *****************************************************************
  61.  
  62. \ Declare necessary Amiga 'C' structures.
  63. NewScreen GameNewScreen
  64. NewWindow GameNewWindow
  65.  
  66.  
  67. VARIABLE Game-SCREEN
  68.  
  69. create aColorTable
  70. hex
  71.    000 w, ccc w, 0d0 w, fff w,
  72.    f00 w, 0dd w, d0d w, 888 w,
  73.    a60 w, 00f w, fd0 w, fca w,
  74.    a60 w, 00f w, fd0 w, fca w, \ This last line is not used
  75.    000 w, ccc w, 0d0 w, fff w, \ And all this is just the same as
  76.    f00 w, 0dd w, d0d w, 888 w, \ the 4 lines above
  77.    a60 w, 00f w, fd0 w, fca w,
  78.    a60 w, 00f w, fd0 w, fca w,
  79. decimal
  80.  
  81.  
  82. : CLOSE.Game.SCREEN ( -- , CLose demo screen )
  83.     game-screen @ closescreen()
  84. ;
  85.  
  86. : OPEN.Game.SCREEN ( -- screen | NULL )
  87.    \ Set to default values.
  88.      GameNewScreen NewScreen.Setup
  89.      GameNewWindow NewWindow.Setup
  90.    \
  91.    \ Modify defaults for this demo.
  92.    HIRES ( LACE | ) SPRITES | GameNewScreen ..! ns_viewmodes
  93.    640   GameNewScreen ..! ns_width
  94.    210   GameNewScreen ..! ns_height
  95.      4   GameNewScreen ..! ns_depth  ( 16 colors )
  96.      0" HexTrix by Kasper Østerbye" >abs
  97.          GameNewScreen ..! ns_DefaultTitle
  98.  
  99.       \ Open Screen and store pointer in NewWindow structure.
  100.    GameNewScreen openscreen() dup Game-Screen !  ( Open screen. )
  101.  
  102.       \ Sometimes the Amiga can build a bad COPPER list for screens.
  103.       \ This can happen if you have Emacs and Workbench up in INTERLACE
  104.       \ mode and open a NON-INTERLACE screen.
  105.       \ The following calls will correct this problem (hopefully).
  106.    dup
  107.    IF  game-screen @ screentoback()
  108.        RemakeDisplay()
  109.        game-screen @ screentofront()
  110.        game-screen @ .. sc_viewport aColorTable 32 loadRGB4()
  111.    THEN
  112.  
  113. ;
  114.  
  115. \ Check for proper opening.
  116. : OPEN.Game.WINDOW  ( screen -- window | NULL )
  117.     >abs GameNewWindow ..! nw_screen
  118.  
  119.     \ Set up window.
  120.     CUSTOMSCREEN   GameNewWindow ..! nw_type
  121.     VANILLAKEY CLOSEWINDOW | INTUITICKS | GameNewWindow ..! nw_idcmpflags
  122.     0" HexTrix in JFORTH -- By Kasper Østerbye" >abs GameNewWindow ..! nw_Title
  123.     0    GameNewWindow ..! nw_TopEdge
  124.     600  GameNewWindow ..! nw_Width
  125.     210  GameNewWindow ..! nw_Height
  126.     GameNewWindow gr.opencurw
  127. ;
  128.  
  129.  
  130. \ ******************************************************
  131. \
  132. \ sprites used for moving pieces
  133. \
  134. \ ******************************************************
  135.  
  136. VARIABLE usingSprites
  137.  
  138. SimpleSprite Sprite-0
  139. SimpleSprite Sprite-1
  140. SimpleSprite Sprite-2
  141. SimpleSprite Sprite-3
  142.  
  143. 2 CONSTANT spriteNumberOffset
  144.  
  145. : SpriteArray ( index -- spriteaddr )
  146.    CASE
  147.       0 OF Sprite-0 ENDOF
  148.       1 OF Sprite-1 ENDOF
  149.       2 OF Sprite-2 ENDOF
  150.       3 OF Sprite-3 ENDOF
  151.    ENDCASE
  152. ;
  153.  
  154. : OPEN.SPRITES ( --  )
  155.    4 0
  156.    DO
  157.        i spriteArray i spriteNumberOffset +  ( we reserve sprites 2,3,4,5 )
  158.          getSprite()
  159.        -1 = ?abort" OPEN.SPRITE - Sprite could not be allocated!"
  160.        0   i spriteArray ..! ss_x
  161.        0   i spriteArray ..! ss_y
  162.        7   i spriteArray ..! ss_height
  163.    LOOP
  164. ;
  165.  
  166. \ Build sprite data, sprites are two planes deep.
  167. 2 base !   ( Use binary to see which bits are on. )
  168. CREATE SPRITE-DATA
  169. here
  170. 0 w,    0 w,   ( position control, used by system. )
  171. \        Plane0                     Plane1
  172.    0001,1111,0000,0000 W,    0001,1111,0000,0000 W,
  173.    0011,1111,1000,0000 W,    0011,1111,1000,0000 W,
  174.    0111,1111,1100,0000 W,    0111,1111,1100,0000 W,
  175.    1111,1111,1110,0000 W,    1111,1111,1110,0000 W,
  176.    0111,1111,1100,0000 W,    0111,1111,1100,0000 W,
  177.    0011,1111,1000,0000 W,    0011,1111,1000,0000 W,
  178.    0001,1111,0000,0000 W,    0001,1111,0000,0000 W,
  179.  
  180.       0 W,     0 W,   ( unattached simple sprite. )
  181.  
  182. here swap - constant SPRITE_DATA_SIZE
  183. decimal
  184.  
  185. 4 ARRAY Sprite-data-ptrs  ( point to ALLOCed CHIP RAM copy )
  186.  
  187. : CHANGE.SPRITES
  188. \ Allocate CHIP memory and copy sprite to it.
  189. \ AMIGAs with more than 512K RAM might be running
  190. \ JForth in FAST RAM.  We could NOT, therefore, use
  191. \ the SPRITE-DATA directly since it would be inaccessable
  192. \ to the graphics coprocessors.
  193.     4 0
  194.     DO
  195.        MEMF_CHIP sprite_data_size allocblock ?dup
  196.        IF
  197.           dup i sprite-data-ptrs !   ( save memory pointer )
  198.           sprite-data swap sprite_data_size cmove ( copy )
  199.           game-screen @ dup IF .. sc_viewport THEN
  200.              i spriteArray  i sprite-data-ptrs @   ChangeSprite()
  201.        ELSE
  202.            ." Unable to allocate all sprites" abort
  203.        THEN
  204.     LOOP
  205. ;
  206.  
  207. : FREE.SPRITES
  208.    4 0
  209.    DO
  210.       i spriteNumberOffset + freesprite()
  211.       i sprite-data-ptrs @ freeblock
  212.    LOOP
  213. ;
  214.  
  215. \ *********************************************************************
  216. \ Misc stuff to go elsewhere later
  217. \ *********************************************************************
  218.  
  219.  
  220. : GVP ( --- relAddr , gameViewPort )
  221.    game-screen @ .. sc_viewport
  222. ;
  223.  
  224. : setRGB4() (  viewPort penNr R G B )
  225.    callvoid>abs graphics_lib setRGB4
  226. ;
  227.  
  228. : SetSpriteColors { penNr -- }  \ had to add '--' mdh
  229.    gvp  23   penNr aColorTable ctable>rgb    setRGB4()
  230.    gvp  27   penNr aColorTable ctable>rgb    setRGB4()
  231. ;
  232.  
  233. : MoveSprite {  x y spr# -- }  \ had to add '--' mdh
  234. \ move sprite to screen coordinate x,y
  235. \ take spriteNumberOffset and hires mode into account
  236.  
  237.    gvp spr# spriteArray x 2+  y moveSprite()
  238. ;
  239.  
  240. : HideSprites
  241.    0 setSpriteColors
  242.    4 0 do 30 30 i MoveSprite loop
  243. ;
  244.  
  245.  
  246. \ ******************************************************
  247. \
  248. \ misc utilities
  249. \
  250. \ ******************************************************
  251.  
  252.  
  253.  
  254.  
  255. : p+ { x y x' y' -- x' y' } ( add the points ) \ changed --> to -- mdh
  256.    x x' +   \ commented out mdh   -> x'
  257.    y y' +   \ commented out mdh   -> y'
  258. ;
  259.  
  260. : p-right { c r  -- c r } ( right-point )
  261.    c 1+ -> c
  262.    c 1 and IF  ELSE r 1+ -> r THEN
  263.    c r   \ added mdh
  264. ;
  265.  
  266. : p-left { c r -- c r } ( left-point )
  267.    c 1- -> c
  268.    c 1 and IF r 1- -> r THEN
  269.    c r   \ added mdh
  270. ;
  271.  
  272.  
  273. : hex>rect ( c r --> c' r' )
  274.    over 2/ -
  275. ;
  276.  
  277. : rect>hex ( c r --> c' r' )
  278.    over 2/ +
  279. ;
  280.  
  281.  
  282. \ **********************************************************
  283. \ INTERNAL BOARD (IB)
  284. \ **********************************************************
  285.  
  286. borderWidth borderHeight * carray ib ( Internal Board )
  287.  
  288. : clearIb
  289.    0 ib borderWidth borderHeight * erase
  290. ;
  291.  
  292. : getIb ( c r --> byte )
  293.    swap borderHeight * + ib c@
  294. ;
  295.  
  296. : putIb ( byte c r --> , store byte )
  297.    swap borderHeight * + ib c!
  298. ;
  299.  
  300.  
  301.  
  302. : isIbEmpty? ( hex-c hex-r --> bool )
  303.    getIb 0=
  304. ;
  305.  
  306. : .Ib
  307.    borderHeight 0
  308.    DO i 4 .r
  309.       borderWidth 0
  310.       DO
  311.          i j getIb 2 .r
  312.       LOOP
  313.